#lang racket


(require mysterx)

(require "../ast/main.rkt"
         "../base/main.rkt"
         "../proxies/main.rkt")

(require "../geometry/main.rkt"
         "../parametrization/main.rkt")

(require (prefix-in alisp: "ac-autolisp.rkt")
         (prefix-in com: "ac-com.rkt"))

(provide
 ; autocad
 (rename-out
  (com:load-autocad-com load-autocad-methods)
  
  (com:active-application-documents-open open)
  (com:active-document-close close)
  (com:get-lens-length-variable get-view-lens)
  (alisp:loft-mark loft-mark))
 regen-active-viewport
 
 ;; layer utils
 delete-all-layers
 (rename-out (object-delete delete-layer))
 delete-layers
 ensure-layer
 get-all-layers
 get-layer
 (rename-out (com:get-layer-name layer-name))
 (rename-out
  (com:get-active-document-active-layer get-active-layer)
  (com:set-active-document-active-layer! set-active-layer!))
 
 ; shapes
 (rename-out (object-get-bounding-box bbox))
 
 ; points
 point
 (rename-out
  (point-name? point?)
  (get-point-coordinates point-c))
 
 ; lines
 arc
 ellipse
 line
 spline
 
 line?
 line-closed?
 polygonal-line?
 
 line-begin-c
 line-cs
 line-end-c
 
 ; surface
 surface
 
 surface?
 
 ; solids
 box
 cone
 cone-frustum
 cylinder
 sphere
 
 solid?
 
 ; generic shapes
 circle
 rectangle
 
 ; text
 text
 
 ; transformations 
 extrude
 intersect
 (rename-out (join-command join))
 loft
 move
 offset
 rotate
 scale
 subtract
 sweep
 union
 
 ; lang
 par
 
 ; cad
 (rename-out (object-copy clone-shape))
 clone-shapes
 (rename-out
  (object-delete delete-shape)
  (alisp:erase-all-command delete-shapes))
 get-shapes
 get-view-center
 get-view-target
 render-shapes
 view)


; macros

(define-syntax define-object-name
  (syntax-rules ()
    ((_ name str)
     (define (name id)
       (string=? (get-object-name id) str)))))

(define-syntax define-ent-fn
  (syntax-rules ()
    ((_ name fn)
     (define (name id)
       (fn (entity-id-ent id))))))


; autocad id

; edit: hash code is different for two com-objects that are com-object-eq?
(struct entity-id id (ent)
  #:constructor-name new-entity-id
  #:property prop:equal+hash
  (let ()
    (define (entity-id=? id1 id2 _)
      (com-object-eq? (entity-id-ent id1) (entity-id-ent id2)))
    (define (entity-id-hash-code id _)
      (equal-hash-code (entity-id-ent id)))
    (define (entity-id-secondary-hash-code id _)
      (equal-secondary-hash-code (entity-id-ent id)))
    (list entity-id=? entity-id-hash-code entity-id-secondary-hash-code))
  #:transparent)

(define (make-entity-id entity/entities)
  (if (list? entity/entities)
      (map new-entity-id entity/entities)
      (new-entity-id entity/entities)))


; autocad

(define-object-name 2d-polyline-name? "AcDb2dPolyline")
(define-object-name 3d-face-name? "AcDbFace")
(define-object-name 3d-polyline-name? "AcDb3dPolyline")
(define-object-name 3d-solid-name? "AcDb3dSolid")
(define-object-name arc-name? "AcDbArc")
(define-object-name circle-name? "AcDbCircle")
(define-object-name ellipse-name? "AcDbEllipse")
(define-object-name light-weight-polyline-name? "AcDbPolyline")
(define-object-name line-name? "AcDbLine")
(define-object-name point-name? "AcDbPoint")
(define-object-name region-name? "AcDbRegion")
(define-object-name spline-name? "AcDbSpline")


(define (add-extruded-solid id height taper-angle)
  (begin0
    (make-entity-id
     (com:add-extruded-solid (entity-id-ent id) height taper-angle))
    (object-delete id)))

(define (add-region ids)
  (begin0
    (make-entity-id
     (com:add-region (map entity-id-ent ids)))
    (for-each object-delete ids)))

; info: fix 2d-polyline 'z' component using elevation property
(define (get-2d-polyline-coordinates id)
  (let ((e (get-object-elevation id)))
    (map
     (λ (c) (z c e))
     (com:get-2d-polyline-coordinates (entity-id-ent id)))))

(define-ent-fn get-3d-polyline-coordinates com:get-3d-polyline-coordinates)

(define (get-light-weight-polyline-coordinates id)
  (let ((e (get-object-elevation id)))
    (map
     (λ (c) (z c e))
     (com:get-light-weight-polyline-coordinates (entity-id-ent id)))))

(define-ent-fn get-object-center com:get-object-center)
(define-ent-fn get-object-closed? com:get-object-closed?)
(define-ent-fn get-object-control-points com:get-object-control-points)
(define-ent-fn get-object-elevation com:get-object-elevation)
(define-ent-fn get-object-end-angle com:get-object-end-angle)
(define-ent-fn get-object-end-point com:get-object-end-point)
(define-ent-fn get-object-name com:get-object-name)
(define-ent-fn get-object-normal com:get-object-normal)
(define-ent-fn get-object-radius com:get-object-radius)
(define-ent-fn get-object-start-angle com:get-object-start-angle)
(define-ent-fn get-object-start-point com:get-object-start-point)
(define-ent-fn get-point-coordinates com:get-point-coordinates)

(define (join-command ids)
  (make-entity-id
   (alisp:join-command (map entity-id-ent ids))))

(define (object-boolean operation object1 object2)
  (make-entity-id
   (com:object-boolean operation (entity-id-ent object1) (entity-id-ent object2))))

(define (object-copy id)
  (make-entity-id
   (com:object-copy (entity-id-ent id))))

(define-ent-fn object-delete com:object-delete)

(define (object-explode id)
  (begin0
    (make-entity-id
     (com:object-explode (entity-id-ent id)))
    (object-delete id)))

(define (object-move id point1 point2)
  (make-entity-id
   (com:object-move (entity-id-ent id) point1 point2)))

(define (object-get-bounding-box id)
  (begin0
    (com:object-get-bounding-box (entity-id-ent id))
    (object-delete id)))

(define (object-transform-by id m)
  (make-entity-id
   (com:object-transform-by (entity-id-ent id) m)))

(define (point c)
  (make-entity-id
   (com:add-point c)))

(define (regen-active-viewport)
  (com:active-document-regen com:ac-active-viewport))


; layer utils

(define (add-layer name)
  (com:active-document-layers-add name))

(define (delete-all-layers)
  (for ((index (in-range 0 (com:get-active-document-layers-count))))
    (com:object-delete (com:active-document-layers-item index))))

(define (delete-layers layers)
  (for-each com:object-delete layers))

(define (ensure-layer name)
  (or (get-layer name) (add-layer name)))

(define (get-all-layers)
  (for/list ((index (in-range 0 (com:get-active-document-layers-count))))
    (com:active-document-layers-item index)))

(define (get-layer name)
  (com:active-document-layers-item name))


; lines

(define (arc angle radius)
  (make-entity-id
   (com:add-arc u0 radius 0 angle)))

(define (ellipse x-radius y-radius)
  (make-entity-id
   (com:add-ellipse u0 (xy x-radius 0) (/ x-radius y-radius))))

(define (line closed? coords)
  (let ((id
         (make-entity-id
          (com:add-3d-poly
           (if closed? (append-first coords) coords)))))
    (when closed?
      (com:set-object-closed! (entity-id-ent id) #t))
    id))

(define (spline closed? cs type)
  (define (spline-impl begin-tangent end-tangent)
    (if closed?
        (make-entity-id
         (com:add-spline (append-first cs) begin-tangent end-tangent))
        (make-entity-id
         (com:add-spline cs begin-tangent end-tangent))))
  (match type
    ((auto-spline-type)
     (let-values (((begin-tangent end-tangent) (spline-tangents cs)))
       (spline-impl begin-tangent end-tangent)))
    ((tangent-spline-type begin-tangent end-tangent)
     (spline-impl begin-tangent end-tangent))))

(define (line? id)
  (or
   (2d-polyline-name? id)
   (3d-polyline-name? id)
   (arc-name? id)
   (circle-name? id)
   (ellipse-name? id)
   (light-weight-polyline-name? id)
   (line-name? id)
   (spline-name? id)))

(define (line-closed? id)
  (or
   (and
    (or
     (2d-polyline-name? id)
     (3d-polyline-name? id)
     (light-weight-polyline-name? id)
     (spline-name? id))
    (get-object-closed? id))
   (circle-name? id)
   (ellipse-name? id)))

(define (polygonal-line? id)
  (or
   (2d-polyline-name? id)
   (3d-polyline-name? id)
   (light-weight-polyline-name? id)
   (line-name? id)
   (and
    (spline-name? id)
    (= (length (get-object-control-points id)) 2))))

; edit: too much repetition?
(define (line-begin-c id)
  (cond ((2d-polyline-name? id)
         (first (get-2d-polyline-coordinates id)))
        ((3d-polyline-name? id)
         (first (get-3d-polyline-coordinates id)))
        ((light-weight-polyline-name? id)
         (first (get-light-weight-polyline-coordinates id)))
        ((line-name? id)
         (get-object-start-point id))
        ((spline-name? id)
         (first (get-object-control-points id)))
        (else
         (error 'line-begin-c "Unhandled line"))))

; edit: too much repetition?
(define (line-cs id)
  (cond ((2d-polyline-name? id)
         (get-2d-polyline-coordinates id))
        ((3d-polyline-name? id)
         (get-3d-polyline-coordinates id))
        ((light-weight-polyline-name? id)
         (get-light-weight-polyline-coordinates id))
        ((line-name? id)
         (list
          (get-object-start-point id)
          (get-object-end-point id)))
        ((spline-name? id)
         (get-object-control-points id))
        (else
         (error 'line-cs "Unhandled line"))))

; edit: too much repetition?
(define (line-end-c id)
  (cond ((2d-polyline-name? id)
         (last (get-2d-polyline-coordinates id)))
        ((3d-polyline-name? id)
         (last (get-3d-polyline-coordinates id)))
        ((light-weight-polyline-name? id)
         (last (get-light-weight-polyline-coordinates id)))
        ((line-name? id)
         (get-object-end-point id))
        ((spline-name? id)
         (last (get-object-control-points id)))
        (else
         (error 'line-end-c "Unhandled line"))))


; surfaces

; surface

; edit: returning first region?
(define (surface-from-closed-line id)
  (first (add-region (list id))))

(define (surface-from-cs cs)
  (make-entity-id
   (match cs
     ((list c1 c2 c3)
      (com:add-3d-face c1 c2 c3))
     ((list c1 c2 c3 c4)
      (com:add-3d-face c1 c2 c3 c4)))))

; edit: returning first region?
(define (surface-from-lines lines)
  (first (add-region lines)))

; edit: returning first region?
(define (surface-from-id id)
  (cond ((line-closed? id)
         (surface-from-closed-line id))
        ; edit: hack or correct? perhaps introduce the concept of polysurface
        (else
         (first (add-region (list id))))))

(define (surface-from-list ids)
  (cond
    ((andmap is-coord ids)
     (surface-from-cs ids))
    ((every line? ids)
     (surface-from-lines ids))
    (else
     (error 'surface-from-list "Unhandled shape"))))

(define (surface ids)
  (cond ((list? ids)
         (surface-from-list ids))
        (else
         (surface-from-id ids))))

; /surface

(define (surface? id)
  (or
   (3d-face-name? id)
   (region-name? id)))


; solids

(define (box width length height)
  (make-entity-id
   (com:add-box u0 width length height)))

(define (cone radius height)
  (make-entity-id
   (com:add-cone (mult-c uz (/ height 2.0)) radius height)))

(define (cone-frustum base-radius top-radius height)
  (make-entity-id
   (alisp:cone-frustum-command u0 base-radius top-radius height)))

(define (cylinder radius height)
  (make-entity-id
   (com:add-cylinder (mult-c uz (/ height 2.0)) radius height)))

(define (sphere radius)
  (make-entity-id
   (com:add-sphere u0 radius)))

(define (solid? id)
  (3d-solid-name? id))


; generic shapes

(define (circle c type radius)
  (match type
    ((line-primitive-type)
     (make-entity-id
      (com:add-circle c radius)))
    ((surface-primitive-type)
     (surface (circle c (line-primitive-type) radius)))))

(define (rectangle type width length)
  (match type
    ((line-primitive-type) 
     (line #t (rectangle-coords width length)))
    ((surface-primitive-type) (surface (rectangle (line-primitive-type) width length)))))


; text

(define text-height 10)

; edit: transform does not seem to affect 'text'
(define (text t r s str)
  (move
   t
   (object-transform-by
    (scale
     (origin-scaling-type)
     s
     (make-entity-id (com:add-text str u0 text-height)))
    r)))


; transformations

(define (extrude length dir id)
  (let ((type
         (if (line? id)
             (alisp:extrusion-type-surface)
             (alisp:extrusion-type-solid)))
        (lengthed-dir (mult-c (norm dir) length)))
    (make-entity-id
     (alisp:extrude-command type (entity-id-ent id) u0 lengthed-dir))))

(define (intersect ids)
  (reduce
   (λ (id2 id1) (object-boolean com:ac-intersection id1 id2))
   ids))


; loft

(define (loft-lines type fit-type closed? ids)
  (let ((ents (alisp:loft-command type fit-type closed? (map entity-id-ent ids))))
    (if (singleton? ents)
        (make-entity-id (first ents))
        (join-command (make-entity-id ents)))))

; edit: this 'join' is very dubious...
(define (loft-surfaces type fit-type closed? ids)
  (let ((borders (map (λ. join-command object-explode) ids)))
    (loft-lines type fit-type closed? borders)))

(define (loft loft-type loft-fit-type closed? ids)
  (let ((type
         (match loft-type
           ((auto-loft-type)
            (cond ((every line? ids) (alisp:loft-type-surface))
                  ((every surface? ids) (alisp:loft-type-solid))
                  (else (error 'loft "Unhandled loft type"))))
           ((surface-loft-type)
            (alisp:loft-type-surface))
           ((solid-loft-type)
            (alisp:loft-type-solid))))
        (fit-type
         (match loft-fit-type
           ((ruled-loft-fit-type) (alisp:loft-fit-type-ruled))
           ((smooth-loft-fit-type) (alisp:loft-fit-type-smooth)))))
    (cond ((every line? ids)
           (loft-lines type fit-type closed? ids))
          ((every surface? ids)
           (loft-surfaces type fit-type closed? ids))
          (else
           (error 'loft "Unhandled loft type")))))

; /loft


(define (move position id)
  (object-move id u0 position))

; edit: getting only the first?
(define (offset distance id)
  (begin0
    (first (make-entity-id (com:object-offset (entity-id-ent id) distance)))
    (object-delete id)))


; rotate

; edit: fix the angle and zero? test with threshold
(define p-distance-threshold 1e-4)

(define (zero-threshold? p (threshold p-distance-threshold))
  (< (xyz-r p) threshold))

(define (rotate angle normal id)
  (if (or (< (abs angle) p-distance-threshold) (zero-threshold? normal))
      id
      (make-entity-id
       (com:object-rotate3d (entity-id-ent id) u0 normal angle))))

; /rotate


(define (scale type size id/ids)
  (define (scale-transform-by id c)
    (object-transform-by id (m-scaling (xyz-x c) (xyz-y c) (xyz-z c))))
  
  (match type
    ((center-scaling-type)
     (error 'scale "AutoCAD scale: center not implemented"))
    ((origin-scaling-type)
     (if (list? id/ids)
         (map (λ (id) (scale-transform-by id size)) id/ids)
         (scale-transform-by id/ids size)))))

(define (subtract ids)
  (reduce
   (λ (id2 id1) (object-boolean com:ac-subtraction id1 id2))
   ids))

(define (sweep path id)
  (let ((type
         (if (line? id)
             (alisp:sweep-type-surface)
             (alisp:sweep-type-solid))))
    (make-entity-id
     (alisp:sweep-command type (entity-id-ent id) (entity-id-ent path)))))


; union

(define ensure-solid-height 1e-5)

(define (union-impl id1 id2)
  (define (ensure-solid-id id)
    (if (surface? id)
        (add-extruded-solid id ensure-solid-height 0)
        id))
  (cond ((or
          (and (solid? id1) (solid? id2))
          (and (surface? id1) (surface? id2)))
         (object-boolean com:ac-union id1 id2))
        (else
         (object-boolean
          com:ac-union
          (ensure-solid-id id1)
          (ensure-solid-id id2)))))

(define (union ids)
  (reduce
   (λ (id2 id1) (union-impl id1 id2))
   ids))

; /union


; lang

; par

(define (arc-length begin-radians end-radians (counter-clockwise? #t))
  (cond ((< begin-radians end-radians) (- end-radians begin-radians))
        (counter-clockwise? (- (+ end-radians 2pi) begin-radians))
        (else (arc-length end-radians begin-radians))))

; edit: fix arc normal
(define (par-arc id)
  (let ((center (get-object-center id))
        (begin-angle (get-object-start-angle id))
        (end-angle (get-object-end-angle id))
        (radius (get-object-radius id)))
    (let* ((angle (arc-length begin-angle end-angle))
           (translation (apply m-translation (list-of-coord center)))
           (rotation (m-rotation begin-angle uz)))
      (make-transformation-parametric
       (make-transformation-parametric
        (make-arc-curve angle radius)
        rotation)
       translation))))

(define (par-circle id)
  (let ((center (get-object-center id))
        (normal (get-object-normal id))
        (radius (get-object-radius id)))
    (let ((translation
           (apply m-translation (list-of-coord center)))
          (rotation
           (m-rotation (angle-c uz normal (cross-c uz normal)) (cross-c uz normal))))
      (make-transformation-parametric
       (make-transformation-parametric
        (make-circle-curve radius)
        rotation)
       translation))))

(define (par id)
  (finally
   (cond ((arc-name? id)
          (par-arc id))
         ((circle-name? id)
          (par-circle id))
         (else
          (error 'par "Unhandled shape, implemented only for arcs and circles")))
   (λ () (object-delete id))))

; /par


; cad

(define (clone-shapes ids)
  (map object-copy ids))

(define (get-shapes)
  (for/list ((i (com:get-active-modelspace-count)))
    (make-entity-id
     (com:active-modelspace-item i))))

(define (get-view-center)
  (add-c (com:get-viewdir-variable) (com:get-target-variable)))

(define (get-view-target)
  (com:get-target-variable))

(define (render-shapes width height path type)
  (when (file-exists? path)
    (delete-file path))
  (let ((render-type
         (match type
           ((draft-render-type) (alisp:render-type-draft))
           ((presentation-render-type) (alisp:render-type-presentation)))))
    (alisp:render-command render-type width height path)))


; view

(define set-view-direction!
  (case-lambda
    ((direction)
     (alisp:dview-command (mult-c direction -1) u0 1))
    ((direction lens)
     (alisp:dview-zoom-command (mult-c direction -1) u0 lens 1))))

(define set-view-center-target!
  (case-lambda
    ((center target)
     (alisp:dview-command center target (distance center target)))
    ((center target lens)
     (alisp:dview-zoom-command center target lens (distance center target)))))

(define (set-view-projection! projection-type)
  (match projection-type
    ((ortho-projection-type)
     (com:set-perspective-variable! com:perspective-off))
    ((perspective-projection-type _)
     (com:set-perspective-variable! com:perspective-on))))

(define (set-view-style! style)
  (let ((view-style
         (match style
           ((realistic-view-style) (alisp:vscurrent-type-conceptual))
           ((wireframe-view-style) (alisp:vscurrent-type-wireframe)))))
    (alisp:vscurrent-command view-style)))

(define (auto-view direction projection-type style id/ids)
  (set-view-projection! projection-type)
  (match projection-type
    ((ortho-projection-type)
     (set-view-direction! direction))
    ((perspective-projection-type lens)
     (set-view-direction! direction lens)))
  (if (list? id/ids)
      (alisp:zoom-objects-command (map entity-id-ent id/ids))
      (alisp:zoom-objects-command (list (entity-id-ent id/ids)))))

(define (manual-view center target projection-type style)
  (set-view-projection! projection-type)
  (match projection-type
    ((ortho-projection-type)
     (set-view-center-target! center target))
    ((perspective-projection-type lens)
     (set-view-center-target! center target lens))))

(define (view type projection-type style id/ids)
  (begin0
    id/ids
    (match type
      ((auto-view-type direction)
       (auto-view direction projection-type style id/ids))
      ((manual-view-type center target)
       (manual-view center target projection-type style)))
    (set-view-style! style)))

; /view